In [1]:
## ---- config----|

start  <- Sys.time()

set.seed(123456)
options(repr.plot.width = 20, repr.plot.height = 12)
options(encoding = 'UTF-8')

list.of.packages <- c("ggwordcloud", "pryr", "tidytext", "visNetwork", "igraph", "topicmodels")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)

end  <- Sys.time()
mem  <- pryr::mem_used()

WriteLog <- function(TaskName, StartTime, EndTime, AdditionalInfo) {

  TotalTime <- difftime(EndTime, StartTime, tz, 
                        units = c("auto", "secs", "mins", "hours",
                                  "days", "weeks"))
  
  log  <- paste('[', Sys.time(), '] ',
                'Task: ', TaskName, ' | ', 
                'Time elapsed: ', format(round(TotalTime, 3), format = '%H:%M:%S'), ' | ',
                'Memory used: ', round(pryr::mem_used() / 1000 / 1000, 0), ' MB | ',
                'Top Memory used: ', round(AdditionalInfo / 1000 / 1000, 0), ' MB | ',
                sep = "")

  write(log, file = "log.txt", append = TRUE)
  #print(log)
}

WriteLog('config', start, end, mem)

## ---- end-of-config----|
Registered S3 method overwritten by 'pryr':
  method      from
  print.bytes Rcpp

Trabalho em Grupo

(até 4 integrantes)

  • Curso: FGV MBA - Business Analytics and Big Data
  • Disciplina: Análise de Mídias Sociais e Mineração de Texto
  • Professor: Gustavo Mirapalheta

Alunos

Github Nome Matricula E-mail
Daniel Campos A57635769 daniel.ferraz.campos@gmail.com
Leandro Daniel A57622988 contato@leandrodaniel.com
Rodrigo Goncalves A57566093 rodrigo.goncalves@me.com
Ygor Lima A57549661 ygor_redesocial@hotmail.com

Enunciado

Apresente uma análise exploratória de dados utilizando as técnicas de Text Mining desenvolvidas na disciplina Análise de Mídias Sociais e Mineração de Texto.

Para esta tarefa iremos utilizar um dataset extraído do Kaggle. Nele, encontram-se disponíveis cerca de 380 mil letras de músicas de uma grande variedade de artistas e gêneros.

Libraries

Aqui estão todas as bibliotecas necessárias para este exercício.

In [4]:
## ---- load_libraries----|

start = Sys.time()

#data_wrangling

library(dplyr, warn.conflicts = FALSE)
library(tidyr, warn.conflicts = FALSE)
library(readr)
library(stringr)
library(tidytext)
library(ggplot2)
library(forcats)

#wordcloud

library(ggwordcloud)

#network_visuallization

library(visNetwork)
library(IRdisplay)
library(igraph, warn.conflicts = FALSE)

#topic_modeling

library(topicmodels)

end = Sys.time()
mem = pryr::mem_used()

WriteLog('load library', start, end, mem)

## ---- end-of-load_libraries----|

Importar e efetuar a limpeza dos dados

In [3]:
## ---- data_ingestion----|

start = Sys.time()

lyrics <- read_csv('lyrics.csv',
                   col_types = cols(
                       index = col_integer(),
                       song = col_character(),
                       year = col_integer(),
                       artist = col_factor(),
                       genre = col_factor(),
                       lyrics = col_character()),
                   locale = locale(encoding = 'UTF-8'))

print(paste('Número de observações: ', length(lyrics$index)))

end   = Sys.time()
mem   = pryr::mem_used()

WriteLog('import lyrics', start, end, mem)

## ---- end-of-data_ingestion----|
[1] "Número de observações:  362237"

Após uma primeira exploração dos dados, notamos a neccessidade de retirar todas as inconsistências e aplicar os seguintes filtros no dataset:

  • Valores faltantes;
  • Gêneros não definidos;
  • Ano anterior a 1970 (poucas observações).
In [4]:
## ---- data_filter----|

start = Sys.time()

lyrics <- filter(lyrics, 
                 !is.na(lyrics), 
                 !(genre %in% c('Not Available', 'Other')),
                 as.integer(year) >= 1970)

# uncomment for fast prototyping
# lyrics  <- sample_n(lyrics, size = 1000)
# invisible(gc())

print(paste('Número de observações: ', length(lyrics$index)))

end = Sys.time()
mem = pryr::mem_used()

WriteLog('filter missing values', start, end, mem)

## ---- en-of-data_filter----|
[1] "Número de observações:  237420"

Vamos também incluir a identificação da década de lançamento da música para enriquescer os dados disponíveis.

In [5]:
## ---- data_enhance----|

start  <- Sys.time()

lyrics$decade <- paste(str_sub(lyrics$year, 1, 3), '0', sep = '')
lyrics$genre  <- trimws(lyrics$genre)

saveRDS(lyrics, 'lyrics.rds')

end  <- Sys.time()
mem = pryr::mem_used()

WriteLog('data enhance', start, end, mem)

## ---- end-of-data_enhance----|

Podemos visualizar uma amostra do dataset que iremos trabalhar.

In [6]:
## ---- view_sample----|

start = Sys.time()

sample_n(lyrics, 25) %>% 
    mutate(lyrics_preview = str_sub(lyrics, 1, 140)) %>% 
    select(-lyrics)

end = Sys.time()
mem = pryr::mem_used()

WriteLog('view sample', start, end, mem)

## ---- end-of-view_sample----|
A spec_tbl_df: 25 × 7
indexsongyearartistgenredecadelyrics_preview
<int><chr><int><fct><chr><chr><chr>
134669three-bells 2008the-browns Pop 2000There's a village hidden deep in the valley Among the pine trees half forlorn And there on a sunny morning Little Jimmy Brown was born (Bung
122608faction 2007candiria Metal 2000Kill This death is comfortable Beggar's life intolerable Running with the madmen Lowest of fears can't fathom Measure your breath in fractio
10220m1-a1 2006gorillaz Rock 2000Hello, hello, is anyone there? Hello, hello, is anyone there? Hello, is anyone there? Hello, is anyone there? Hello, is anyone there? Hello,
316661twist-and-shout 2006deacon-blue Rock 2000You`ve got a lot of Tings to say about the Big world and the High skies so you Walk a little in a Long mile to be Sure your eyes can see the
160186adonde-iran-los-besos-victor-manuel 1999ana-belasn Pop 1990Tu beso tembloroso y programa doble, cinco pesetas en el momento justo nos enchufaban con la linterna. Cuntos atardeceres por las callejas s
288845rebellion 2007aina Metal 2000[Talon: Glenn Hughes] [Backing vox: Tobias Sammet] [Talon:] The mountains are calling The heavens, they beckon her home Our sadness is falli
91610too-much-too-soon 2007celestial-season Rock 2000Even the words came back, but I cannot rely on what they became to me even the sounds came back, but it's hard to hear the vibes when you aw
221407just-can-t-get-enough 2010black-eyed-peas Hip-Hop2010Boy I think about it every night and day I'm addicted wanna jump inside your love I wouldn't wanna have it any other way I'm addicted and I
278824in-this-son 2009charice Pop 2000I may not know Where I'm going now This broken road Is trying to tear me down But deep inside I found A sacred place That I never knew Where
309142when-the-time-s-right 2004akon Pop 2000Yeah, what up, I go by the name of Divine, I got my boy Akon in the back But before I bring him out, I want all the ladies Come on, ok, ok,
120233loving-me-back-to-life 2005geri-halliwell Pop 2000I've been looking for love in all the wrong places Different names, familiar faces I've watched the moon go through its phases But now I lov
89955cash 2007big-moe Hip-Hop2000[Chorus: Noke D] I'm talking cash, nigga Gripping grain, swanging lanes We talking cash, nigga Candy paint on all them Range We talking cash
316558freedom-train 2006deacon-blue Rock 2000(Cover Version) The freedom train is coming, can't you hear the whistle blowing Its time get your ticket and get on board Its time for all t
187644you-gotta-burn 2007dwarves Rock 2000I had some schooling But they threw me away For being in prison and refusing to pray but still I'm greatful For the things that I've learned
115104pepe-botika-donde-estan-mis-amigos 1997extremoduro Rock 1990Pepe Botika es un honrado traficante tomando copas me l'encuentro to los días me cuenta historias de sus años en la cárcel a veces había
208775once-upon-my-nightstand 2006finch Rock 2000I'm sleeping to give my head a rest I am so sick of these arguments Alone, once again I'm on my own Just need some time to myself or I'll ex
287898darlin-dear 2006chicago Rock 2000Since we talked Half the night Feelin' good Feelin' right Words were spoke Brought us close When we touched it was overdose On the road You'
360901purity-throught-fire 2006belphegor Metal 2000Pushed down the stairs - built of coffins Morbid fear - in the dungeons Tied to the rack - knife across your breasts Beaten and strangled -
174497wake-you-with-a-kiss 2015aaron-pritchett Country2010You're a little to drunk to drive and I'm a little too into you to let you go, I ain't ready to kiss you goodbye just yet and let you disapp
230514please-set-the-date 2007b-b-king Rock 2000Hey baby, baby please set a date Hey baby, baby please set a date Well, don't say tomorrow 'Cause tomorrow is too far away Now, when I want
245030romeos 2006alphaville Pop 2000Here's a boy With a little black dog There's a boy With a little black dog And he looks At his watch For a while And the falling years Wash
275242a-little-death-around-the-eyes 2007babyshambles Rock 2000A little death around the eyes Take your medicine in your hotel room That's your medicine Better rest on all fours That's your medicine In a
37323remembering-britt 2007a-day-at-the-fairRock 2000You've got you're brand new house, you've got you're brand new room. You've got the pictures on the wall and I'm not in any of them. I've go
175377whatever-hurts-you-through-the-night2011glasvegas Rock 2010I see you in the night walking past my house I wonder if you feel the same as I do Just like me trapped and bruised And lost and lonely too
186961johnny-grey 2006eiffel-65 Pop 2000My Name Is Johnny Grey, It's Just A Name And I Know That For You It's The Same The World I Know Seems Not To Know Me Here's My Number I Need

Análise Exploratória dos Dados Inicial

Ficamos com cerca de 237 mil letras de músicas que utilizaremos para analisar diversos aspectos utilizando técnicas de mineração de texto e análise de rede tais como:

  • Identificar as palavras e bigramas que são mais utilizadas por gênero musical.
  • Apresentar os bigramas mais utilizados por gênero e artista.
  • Segregação das palavras mais utilizadas por sentimento.
  • Aplicar a técnica de TF-IDF para emilinação de stop words.
  • Aplicar a técnica de topic modeling para segmentação das canções.

Abaixo uma pequena exploração do dataset selecionado.

  • Quantidade de músicas e artistas por gênero musical.
In [7]:
## ---- number_of_observations_per_genre----|

start = Sys.time()

temp <- group_by(lyrics, genre) %>%
  summarise(songs = n(),
            artists = length(unique(artist))) %>% 
  arrange(desc(songs))

ggplot(data = temp, aes(x = fct_reorder(genre, songs), y = songs)) +
    geom_bar(stat = 'identity', aes(fill = genre)) +
    geom_label(aes(label = paste('songs:', songs, '\nartists: ', artists, sep = ''),
                   y = 1000, fill = genre), size = 8, hjust = 'left', alpha = 0.25) +
    coord_flip() +
    xlab('Genre') +
    ylab('') +
    labs(title = 'Songs and Artists by Genre') +
    theme(legend.position = 0,
         text = element_text(size = 20),
         axis.text.x = element_blank())

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot obs per genre', start, end, mem)

## ---- end-of-number_of_observations_per_genre----|
  • Quantidade de músicas e artistas por década.
In [8]:
## ---- number_of_observations_per_decade----|

start = Sys.time()

temp  <- group_by(lyrics, decade) %>% 
            summarise(songs = n(),
                      artists = length(unique(artist))) %>% 
            arrange(desc(decade))

ggplot(data = temp, aes(x = decade, y = songs)) +
    geom_bar(stat = 'identity', aes(fill = decade)) +
    geom_label(aes(label = paste('songs:', songs, '\nartists: ', artists, sep = ''),
                   y = 1000, fill = decade), size = 8, hjust = 'left', alpha = 0.25) +
    coord_flip() +
    xlab('Decade') +
    ylab('') +
    labs(title = 'Songs and Artists by Decade') +
    theme(legend.position = 0,
         text = element_text(size = 20),
         axis.text.x = element_blank())

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot obs per decade', start, end, mem)

## ---- end-of-number_of_observations_per_decade----|
  • Top 3 artistas, em relação a quantidade de músicas, por gênero.
In [9]:
## ---- top_artists----|

start = Sys.time()

count(lyrics, genre, artist, sort = TRUE) %>% 
  group_by(genre) %>% 
  arrange(desc(n)) %>% 
  filter(row_number() <= 3) %>% 
  arrange(desc(genre), desc(n))

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot top artists', start, end, mem)

## ---- end-of-top_artists----|
A grouped_df: 30 × 3
genreartistn
<chr><fct><int>
Rock elton-john 676
Rock bob-dylan 596
Rock david-bowie 570
R&B babyface 367
R&B aretha-franklin 282
R&B brian-mcknight 214
Pop barbra-streisand 607
Pop bee-gees 591
Pop american-idol 568
Metal fall 368
Metal cradle-of-filth 183
Metal anthrax 183
Jazz ella-fitzgerald 571
Jazz dean-martin 560
Jazz frank-sinatra 417
Indie devendra-banhart 141
Indie dar-williams 102
Indie the-blood-brothers 85
Hip-Hop chris-brown 628
Hip-Hop eminem 578
Hip-Hop 50-cent 398
Folk clannad 194
Folk celtic-woman 125
Folk gordon-lightfoot 91
Electronicbjrthrk 237
Electronicdavid-guetta 149
Electroniceverything-but-the-girl134
Country dolly-parton 744
Country eddy-arnold 591
Country bill-anderson 466

Análise Exploratória de Dados

Análise de palavras mais comuns.

Vamos utilizar o pacote tidytext para tokenizar os termos em um dataframe contendo uma palavra por linha.

In [10]:
## ---- get_tokens----|

start  <- Sys.time()

lyrics_token <- unnest_tokens(lyrics,
                              input = lyrics,
                              output = word,
                              token = 'words',
                              drop = TRUE,
                              to_lower = TRUE)

print(paste('Número de observações: ', length(lyrics_token$index)))

end  <- Sys.time()
mem = pryr::mem_used()

WriteLog('get tokens', start, end, mem)

## ---- end-of-get_tokens----|
[1] "Número de observações:  54725191"
In [11]:
rm(lyrics)
invisible(gc())

Algumas músicas, ou mesmo parte da letra, estão em outros idiomas além do inglês.

Para resolver isso vamos aplicar mais dois filtros, onde eliminamos termos que não iniciam com letras {a- z}e stop words em outros idiomas de origem latina.

Também eliminamos palavras com menos de 3 caracteres, uma vez que usualmente estas não representam tópicos ou temas relevantes.

Adicionalmente utilizamos o dicionário de sentimentos bing para associar o sentimento a cada palavra do dataset.

In [12]:
## ---- eliminating_stopwords----|

start  <- Sys.time()

custom_stop_words <- c(tm::stopwords("german"), tm::stopwords("spanish"), 
                       tm::stopwords("portuguese"), tm::stopwords("french"),
                       stop_words$word, 'chorus', 'repeat', 'versus', 'chorus:repeat', 
                       'instrumental')

lyrics_token <- filter(lyrics_token,
                       str_detect(word, '^[a-z]') &
                       !(word %in% custom_stop_words) &
                       nchar(word) >= 3)

bing = get_sentiments('bing')
lyrics_token$sentiment = plyr::mapvalues(lyrics_token$word, 
                                         bing$word, bing$sentiment, 
                                         warn_missing = FALSE)

lyrics_token$sentiment = if_else(!(lyrics_token$sentiment %in% c('positive', 'negative')), 
                                    'neutral', lyrics_token$sentiment)

print(paste('Número de observações após a eleminação das stop words: ', 
            length(lyrics_token$index)))

sample_n(lyrics_token, size = 15)

count_words <- count(lyrics_token, word, sentiment, sort = TRUE)

# saving datasets for later use.
saveRDS(lyrics_token, 'lyrics_token.rds')
saveRDS(count_words, 'count_words.rds')

mem  <- pryr::mem_used()
rm(bing, count_words)
invisible(gc)

end = Sys.time()

WriteLog('save token lyrics', start, end, mem)

## ---- end-of-eliminating_stopwords----|
[1] "Número de observações após a eleminação das stop words:  18430707"
A spec_tbl_df: 15 × 8
indexsongyearartistgenredecadewordsentiment
<int><chr><int><fct><chr><chr><chr><chr>
147018fallin-in-love 2006david-hasselhoff Rock 2000gate neutral
153438afraid-with-you 2016christon-gray Hip-Hop2010true neutral
60995down 2007cross-canadian-ragweedRock 2000swore neutral
362145run 2013dub-fx Hip-Hop2010connectingneutral
251805miento-cuando-digo-que-lo-siento2013enrique-bunbury Rock 2010control neutral
359258365 2010black-milk Hip-Hop2010wrong negative
264859everything-glorious 2007david-crowder Rock 2000glorious positive
105229the-dope-man 2004cam-ron Hip-Hop2000mound neutral
16960poison 2008adrienne-young Country2000poison negative
120405for-ur-love 2009chris-brown Hip-Hop2000hope neutral
33902war-battlecry-remix 2006bone-thugs-n-harmony Hip-Hop2000focus neutral
266790la-boda 2014aventura Pop 2010ama neutral
251581picture-pains 2006grammatrain Rock 2000wondering neutral
132229leve 2016cartel-de-santa Hip-Hop2010dije neutral
156815inner-logic 2006bad-religion Rock 2000stroll neutral

De posse do dataset organizado, vamos iniciar com a contagem relativa dos termos por gênero musical.

In [13]:
## ---- count_tokens----|

start  <- Sys.time()

gw <- group_by(lyrics_token, genre, sentiment, word) %>%
  summarise(gw_c = n()) %>% 
  ungroup() %>% 
  group_by(genre) %>%
  mutate(gw_p = gw_c / sum(gw_c)) %>% 
  ungroup() %>%
  arrange(genre, desc(gw_p)) %>% 
  group_by(word) %>% 
  mutate(w_c = sum(gw_c))

# contagem por palavra
w <- group_by(lyrics_token, sentiment, word) %>%
  summarise(w_c = n()) %>% 
  ungroup() %>%
  mutate(w_p = w_c / sum(w_c)) %>%
  arrange(desc(w_c))

mem  <- pryr::mem_used()
rm(lyrics_token)
invisible(gc)

end = Sys.time()

WriteLog('count tokens', start, end, mem)

## ---- end-of-count_tokens----|

Vamos iniciar a exploração observando as 100 palavras mais comuns, por sentimento, encontradas no dataset como um todo.

In [14]:
## ---- view_wordcloud_token----|

start  <- Sys.time()

temp <- group_by(w, sentiment) %>% 
    arrange(desc(w_c)) %>% 
    filter(row_number() < 101) %>% 
    mutate(angle = 90 * sample(c(0, 1), n(), replace = TRUE, prob = c(70, 30)),
          freq_sd = (w_c - min(w_c)) / (max(w_c) - min(w_c))) %>% 
    ungroup()

options(repr.plot.width = 20, repr.plot.height = 6)

plt  <- ggplot(data = temp,
  aes(label = word, 
      size = w_c,
      color = factor(sentiment), 
      angle = angle)) +
  geom_text_wordcloud_area(eccentricity = 0.65) +
  facet_wrap(vars(sentiment), nrow = 1) +
  scale_size_area(max_size = 35) +
  theme_minimal() +
  theme(text = element_text(size = 20))

suppressWarnings(print(plt))

mem  <- pryr::mem_used()
rm(w)
invisible(gc)

end = Sys.time()

WriteLog('token lyrics wordcloud', start, end, mem)

## ---- end-of-view_wordcloud_token----|

Também podemos verificar as palavras mais utilizadas por sentimento e gênero musical.

Aqui o tamanho de cada termo é dado pela frequência de cada combinaçao de sentimento e gênero musical, de forma que quanto maior a nuvem de palavra maior a diversidade de palavras utilizadas para o a combinação de sentimento e gênero musical.

Podemos observar quem em geral os temas positivos estão concentrados na palavra "love", para as palavras neutras a predominância da palavra "time", já os temas negativos são muito mais diversos entre os gêneros musicais.

In [15]:
## ---- wordcloud_per_genre_token----|

start <- Sys.time()

temp <- group_by(gw, genre, sentiment) %>%  
    arrange(desc(gw_p)) %>% 
    filter(row_number() < 51) %>%
    mutate(angle = 90 * sample(c(0, 1), n(), replace = TRUE, prob = c(70, 30)), 
           freq_sd = (gw_c - min(gw_c)) / (max(gw_c) - min(gw_c))) %>% 
    ungroup()

options(repr.plot.width = 20, repr.plot.height = 48)

plt <- ggplot(data = temp,
  aes(label = word, 
      size = freq_sd,
      color = factor(sample.int(20, nrow(temp), replace = TRUE)), 
      angle = angle)) +
  geom_text_wordcloud_area() +
  scale_size_area(max_size = 25) +
  facet_wrap(genre ~ sentiment, nrow = 10) +
  theme(text = element_text(size = 15))

suppressWarnings(print(plt))

end = Sys.time()
mem = pryr::mem_used()

WriteLog('token lyrics wordcloud per genre', start, end, mem)

## ---- end-of-wordcloud_per_genre_token----|

Na sequência vamos verificar se as 10 palavras mais comuns são uniformes entre os gêneros musicais presentes no dataset.

In [16]:
## ---- top_10_words_token----|

start = Sys.time()

options(repr.plot.width = 20, repr.plot.height = 12)

gw %>%
  group_by(genre) %>% 
  arrange(desc(gw_p)) %>% 
  filter(row_number() <= 10) %>%
  mutate(rank = row_number()) %>% 
  ggplot() +
  geom_bar(stat = 'identity',
           aes(y = gw_p, x = fct_reorder(word, w_c), fill = genre)) +
  geom_text(aes(label = as.character(rank), x = fct_reorder(word, w_c), y = 0.002)) +
  facet_wrap(vars(genre), nrow = 1) +
  coord_flip() +
  xlab('Word') +
  ylab('Relative frequency') +
  labs(title = 'Top 10 words by music genre') +
  theme(legend.position = 0,
        axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        text = element_text(size = 20))

rm(gw)
invisible(gc)

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot top words', start, end, mem)

## ---- end-of-top_10_words_token----|

Como podemos observar pelo gráfico acima em geral as top 10 palavras são as mesmas entre os gêneros, porém, os gêneros Metal e Hip-Hop se destacam com diferentes temas em relação aos demais gêneros.

Também observamos que Country, Folk e Indie abordam com maior frequência o tema "Home" em relação aos demais.

Análise de Bigramas

Além da análise das palavras mais comuns podemos explorar quais são os Bigramas mais comuns.

In [17]:
## ---- get_tokens_bigrams----|

start  <- Sys.time()

lyrics <- readRDS('lyrics.rds')

lyrics_token_bi <- unnest_tokens(lyrics,
                                 input = lyrics,
                                 output = term,
                                 token = 'ngrams',
                                 drop = TRUE,
                                 to_lower = TRUE,
                                 n = 2)

print(paste('Número de termos: ', nrow(lyrics_token_bi)))

end = Sys.time()
mem = pryr::mem_used()

WriteLog('get tokens bigrams', start, end, mem)

## ---- end-of-get_tokens_bigrams----|
[1] "Número de termos:  54492310"

Agora separamos o bigrama em duas palavras para eliminarmos as observações que contem stop words assim como fizemos com o a análise de palavras individuais.

In [18]:
rm(lyrics, plt, temp)
invisible(gc())

Iremos eliminar as linhas onde ao menos uma das palavras do bigrama é uma stop words.

Além das stop words, por estarmos analisando letras de músicas, também vamos excluir as observações com palavras repetidas.

In [19]:
## ---- clean_bigrams----|

start  <- Sys.time()

lyrics_token_bi <- separate(lyrics_token_bi, term, 
                            sep = ' ',
                            into = c('w1', 'w2'), 
                            remove = FALSE)

lyrics_token_bi <- filter(lyrics_token_bi, w1 != w2)

lyrics_token_bi <- filter(lyrics_token_bi, nchar(w1) >= 3, nchar(w2) >= 3)

invisible(gc())

lyrics_token_bi <- filter(lyrics_token_bi, 
                          !(w1 %in% custom_stop_words) & str_detect(w1, '^[a-z]'))

lyrics_token_bi <- filter(lyrics_token_bi, 
                          !(w2 %in% custom_stop_words) & str_detect(w2, '^[a-z]'))

saveRDS(lyrics_token_bi, 'lyrics_token_bi.rds')

print(paste('Número de termos apos eliminação de stop words: ', 
            nrow(lyrics_token_bi)))

mem  <- pryr::mem_used()

rm(lyrics_token_bi)
invisible(gc)

end = Sys.time()

WriteLog('save tokens lyrics bigrams', start, end, mem)

## ---- end-of-clean_bigrams----|
[1] "Número de termos apos eliminação de stop words:  5221340"

Vamos criar uma função para gerar um diagrama de rede com os 5 bigramas mais comuns para cada palavra selecionadas.

In [8]:
## ---- plot_network----|

plot_network <- function(top_words = 25, 
                         artist_filter = NULL, 
                         genre_filter = NULL) {
    # load required data
    count_words  <- readRDS('lyrics_token.rds')
    data         <- readRDS('lyrics_token_bi.rds')
    
    # apply filters

    if (!is.null(artist_filter)) {count_words  <- filter(count_words, 
                                                         artist %in% artist_filter)}
    
    if (!is.null(genre_filter)) {count_words   <- filter(count_words, 
                                                         genre %in% genre_filter)}
    
    count_words  <- count(count_words, word, sentiment, sort = TRUE)
    
    top_words <- filter(count_words, row_number() <= top_words)
    
    if (!is.null(artist_filter)) {data  <- filter(data, 
                                                  artist %in% artist_filter)}
    
    if (!is.null(genre_filter)) {data  <- filter(data, 
                                                 genre %in% genre_filter)}
    
    data <- group_by(data, w1, w2) %>% 
               summarise(count = n()) %>%
               ungroup() %>%
               mutate(percent = count / sum(count)) %>%
               group_by(w1) %>%
               arrange(desc(count)) %>%
               filter(row_number() <= 5) %>% 
               ungroup() %>% 
               filter(w1 %in% top_words$word)

    # set nodes
    nodes = tibble(label = unique(c(data$w1, data$w2)))
    
    nodes = tibble::rowid_to_column(nodes, "id")
    
    nodes$value = plyr::mapvalues(nodes$label, count_words$word, 
                                  count_words$n, warn_missing = FALSE)
    
    nodes$value = as.numeric(nodes$value)
    
    nodes$value = (nodes$value - min(nodes$value)) / 
                                    (max(nodes$value) - min(nodes$value))
    
    nodes$value = nodes$value * 100
    
    nodes$group = plyr::mapvalues(nodes$label, count_words$word, 
                                  count_words$sentiment, warn_missing = FALSE)

    # set edges
    edges  <- tibble(from   = data$w1,
                     to     = data$w2,
                     weight = data$percent)
    
    edges$from = plyr::mapvalues(edges$from, nodes$label, 
                                 nodes$id, warn_missing = FALSE)
    
    edges$to = plyr::mapvalues(edges$to, nodes$label, 
                               nodes$id, warn_missing = FALSE)

    net_graph <- visNetwork(nodes, edges, height = "500px", width = "100%") %>% 
                     visNodes(scaling = list(min = 10, max = 50), 
                              physics = TRUE, mass = 1.25) %>% 
                     visEdges(arrows = "to") %>% 
                     visOptions(highlightNearest = TRUE, 
                                nodesIdSelection = TRUE,
                                selectedBy = "group") %>%
                     visGroups(groupname = "positive", color = "green")  %>% 
                     visGroups(groupname = "neutral") %>% 
                     visGroups(groupname = "negative", color = "red") %>% 
                     visLegend(width = 0.1)
    
    rm(count_words, data)
    invisible(gc)
    
    # return graph
    return (net_graph)
}

## ---- end-of-plot_network----|

Aqui estamos vendo os 5 bigramas mais comuns para as 25 palavras mais usadas em todo o dataset.

Todo o dataset

In [13]:
## ---- plot_network_all----|

start  <- Sys.time()

net_graph <- plot_network(top_words = 25)

htmlwidgets::saveWidget(net_graph, "net_graph.html")

display_html('<iframe src="net_graph.html" width=100% height=600></iframe>')

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot net 1', start, end, mem)

## ---- end-of-plot_network_all----|

Agora podemos aplicar um filtro no dataset de bigramas e verificar a rede de bigramas de um artista em aprticular como Bob Dylan.

Aqui estamos vendo os 5 bigramas mais comuns para as 50 palavras mais usadas pelo artista.

Bob Dylan

In [14]:
## ---- plot_network_artist----|

start  <- Sys.time()

net_graph <- plot_network(top_words = 50, artist_filter = 'bob-dylan')

htmlwidgets::saveWidget(net_graph, "net_graph_artist.html")

display_html('<iframe src="net_graph_artist.html" width=100% height=600></iframe>')

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot net 2', start, end, mem)

## ---- end-of-plot_network_artist----|

Podemos fazer o mesmo filtro para um gênero musical específico como Metal e Rock.

Metal

In [15]:
## ---- plot_network_genre_1----|

start  <- Sys.time()

net_graph <- plot_network(top_words = 25, genre_filter = 'Metal')

htmlwidgets::saveWidget(net_graph, "net_graph_genre_1.html")

display_html('<iframe src="net_graph_genre_1.html" width=100% height=600></iframe>')

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot net 3', start, end, mem)

## ---- end-of-plot_network_genre_1----|

Rock

In [16]:
## ---- plot_network_genre_2----|

start  <- Sys.time()

net_graph <- plot_network(top_words = 25, genre_filter = 'Rock')

htmlwidgets::saveWidget(net_graph, "net_graph_genre_2.html")

display_html('<iframe src="net_graph_genre_2.html" width=100% height=600></iframe>')

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot net 4', start, end, mem)

## ---- end-of-plot_network_genre_2----|

A exemplo do que fizemos com a contagem individual de palavras vamos verificar quais os bigramas mais utilizados por gênero musical.

In [25]:
## ---- top_bigrams_token----|

start  <- Sys.time()

lyrics_token_bi <- readRDS('lyrics_token_bi.rds')

gw <- group_by(lyrics_token_bi, genre, term) %>%
  summarise(gw_c = n()) %>% 
  ungroup() %>% 
  group_by(genre) %>%
  mutate(gw_p = gw_c / sum(gw_c)) %>% 
  ungroup() %>%
  arrange(genre, desc(gw_p)) %>% 
  group_by(term) %>% 
  mutate(w_c = sum(gw_c))

# contagem por palavra
w <- group_by(lyrics_token_bi, term) %>%
  summarise(w_c = n()) %>% 
  ungroup() %>%
  mutate(w_p = w_c / sum(w_c)) %>%
  arrange(desc(w_c))

mem  <- pryr::mem_used()

rm(lyrics_token_bi)
invisible(gc)

end = Sys.time()
mem = pryr::mem_used()

WriteLog('calculate tokens lyrics bigram count', start, end, mem)

## ---- end-of-top_bigrams_token----|

Vamos verificar a nuvem de termos de bigramas.

In [26]:
## ---- view_wordcloud_token_bigrams----|

start  <- Sys.time()

temp <- arrange(w, desc(w_c)) %>% 
    filter(row_number() < 101) %>% 
    mutate(angle = 90 * sample(c(0, 1), n(), replace = TRUE, prob = c(70, 30)))

plt <- ggplot(data = temp,
  aes(label = term, 
      size = w_c,
      color = factor(sample.int(20, nrow(temp), replace = TRUE)), 
      angle = angle)) +
  geom_text_wordcloud_area(eccentricity = 1.1) +
  scale_size_area(max_size = 25) +
  theme_minimal()

mem  <- pryr::mem_used()

rm(w)
invisible(gc)

suppressWarnings(print(plt))

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot tokens lyrics bigrams', start, end, mem)

## ---- end-of-view_wordcloud_token_bigrams----|
In [27]:
## ---- view_wordcloud_token_bigrams_per_genre----|

start  <- Sys.time()

temp <- group_by(gw, genre) %>%  
    arrange(desc(gw_p)) %>% 
    filter(row_number() < 26) %>%
    mutate(angle = 90 * sample(c(0, 1), n(), replace = TRUE, prob = c(100, 0)), 
           freq_sd = (gw_c - min(gw_c)) / (max(gw_c) - min(gw_c))) %>% 
    ungroup()

options(repr.plot.width = 20, repr.plot.height = 24)

plt <- ggplot(data = temp,
  aes(label = term, 
      size = freq_sd,
      color = factor(sample.int(20, nrow(temp), replace = TRUE)), 
      angle = angle)) +
  geom_text_wordcloud_area() +
  scale_size_area(max_size = 20) +
  facet_wrap(vars(genre), nrow = 5) +
  theme(text = element_text(size = 20))  

suppressWarnings(print(plt))

end = Sys.time()
mem = pryr::mem_used()

WriteLog('plot tokens lyrics bigrams per genre', start, end, mem)

## ---- end-of-view_wordcloud_token_bigrams_per_genre----|

Agora verificamos os top 5 bigramas por gênero musical.

In [28]:
## ---- top_5_words_token_bigrams----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 12)

gw %>%
  group_by(genre) %>% 
  arrange(desc(gw_p)) %>% 
  filter(row_number() <= 5) %>%
  mutate(rank = row_number()) %>% 
  ggplot() +
  geom_bar(stat = 'identity',
           aes(y = gw_p, x = fct_reorder(term, w_c), fill = genre)) +
  geom_text(aes(label = as.character(rank), x = fct_reorder(term, w_c), y = 0.0002)) +
  facet_wrap(vars(genre), nrow = 1) +
  coord_flip() +
  xlab('Term') +
  ylab('Relative frequency') +
  labs(title = 'Top 5 bigrams by music genre') +
  theme(legend.position = 0,
        axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        text = element_text(size = 20))

mem  <- pryr::mem_used()

rm(gw)
invisible(gc)

end = Sys.time()

WriteLog('plot top words bigrams', start, end, mem)

## ---- end-of-top_5_words_token_bigrams----|

TF-IDF (Term Frequency - Inverse Document Frequency)

Esta métrica é uma medida estatística que tem o intuito de indicar a importância de uma palavra de um documento em relação a uma coleção de documentos.

O valor tf–idf de uma palavra aumenta proporcionalmente à medida que aumenta o número de ocorrências dela em um documento, no entanto, esse valor é equilibrado pela frequência da palavra no corpus. Isso auxilia a distinguir o fato de a ocorrência de algumas palavras serem geralmente mais comuns que outras como as stopwords.

\begin{equation} W_{i,j} = tf_{i,j} * log(\frac{N}{df_i}) \end{equation}\begin{equation} tf_{i,j} = \text{ número de ocorrencias do termo } \textit{( i )} \text{ em } \textit{ j } \text{ (documento)} \end{equation}

\begin{equation} df_{i} = \text{ número de documentos contendo } \textit {i} \end{equation}

\begin{equation} N = \text{ número total de documentos } \end{equation}

\begin{equation} W_{i,j} = \text{ Term Frequency - Inverse Document Frequency } \end{equation}

Neste exercício o documento será um gênero musical.

Vamos verificar se conseguimos identificar as principais palavras de cada gênero musical sem o auxílio de um dicionário de stopwords.

Começamos calculando a frequência de cada termo.

In [29]:
## ---- calculate_term_frequency----|

start  <- Sys.time()

lyrics <- readRDS('lyrics.rds')

# tokennize dataset but do not treat for stopwords.
lyrics_token <- unnest_tokens(lyrics,
                              input = lyrics,
                              output = word,
                              token = 'words',
                              drop = TRUE,
                              to_lower = TRUE)

# calculate the term frequency by gere.
lyrics_token <- lyrics_token[, c('genre','word')] %>% 
    filter(str_detect(word, "^[a-z']")) %>% 
    group_by(genre, word) %>% 
    summarise(n = n()) %>% 
    group_by(genre) %>% 
    mutate(total = sum(n)) %>% 
    mutate(tf = n / total) %>% 
    group_by(genre) %>% 
    arrange(desc(n)) %>%
    mutate(rank_tf = row_number()) %>%
    ungroup()

# display the most commom terms based on its term frequency.
    filter(lyrics_token, rank_tf <= 3) %>% 
    arrange(genre, rank_tf)

mem  <- pryr::mem_used()

rm(lyrics)
invisible(gc)

end = Sys.time()
mem = pryr::mem_used()

WriteLog('calculate tf', start, end, mem)

## ---- end-of-calculate_term_frequency----|
A tibble: 30 × 6
genrewordntotaltfrank_tf
<chr><chr><int><int><dbl><int>
Country the103973 26794870.038803321
Country i 91742 26794870.034238642
Country you 75767 26794870.028276683
Electronicthe 54825 15448860.035488061
Electronicyou 53800 15448860.034824582
Electronici 49534 15448860.032063213
Folk the 18199 4072090.044692041
Folk and 10935 4072090.026853532
Folk i 10469 4072090.025709163
Hip-Hop the450760122080260.036923251
Hip-Hop i 357582122080260.029290732
Hip-Hop you311165122080260.025488563
Indie the 24750 6216080.039816091
Indie i 21678 6216080.034874072
Indie you 20160 6216080.032432023
Jazz the 46727 13796480.033868781
Jazz you 44560 13796480.032298092
Jazz i 43283 13796480.031372503
Metal the210836 40088570.052592551
Metal i 95301 40088570.023772612
Metal to 93061 40088570.023213853
Pop you371530 99791520.037230621
Pop i 338614 99791520.033932142
Pop the289530 99791520.029013493
R&B you 33255 7676590.043320021
R&B i 29320 7676590.038194042
R&B the 23534 7676590.030656843
Rock the810185208565670.038845561
Rock i 661465208565670.031714952
Rock you660341208565670.031661063

Podemos perceber que são exatamente as stop words os termos com maior frequência.

Podemos visualizar a quantidade de termos por frequência em um histograma.

Verificamos que a maioria dos termos tem uma frequência muito baixa, como é esperado.

In [30]:
## ---- histogram_term_frequency----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 24)

ggplot(lyrics_token, aes(x = n / total, fill = genre)) +
  geom_histogram(show.legend = FALSE, bins = 60) + 
  facet_wrap( ~ genre, ncol = 2, scales = 'free') +
  theme(text = element_text(size = 20))

end <- Sys.time()

WriteLog('plot histogram of tf', start, end, pryr::mem_used())

## ---- end-of-histogram_term_frequency----|

Aqui verificamos a relação entre a frequência do termo, no gênero com, o rank do termo.

In [31]:
## ---- term_frequency_vs_rank----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 12)

ggplot(lyrics_token, aes(x = rank_tf, y = tf, color = genre)) +
  geom_line(alpha = 0.8, size = 1.1, show.legend = FALSE) +
  scale_x_log10() + scale_y_log10() +
  xlab("Rank - Term frequency") + ylab("Term frequency") + 
  labs(title = 'Term frequency vs Rank - Log Scale') +
  theme(text = element_text(size = 20))

end  <- Sys.time()

WriteLog('plot term frequency vs rank', start, end, pryr::mem_used())

## ---- end-of-term_frequency_vs_rank----|

O fato de haver algumas canções em outros idiomas, que não o inglês, faz com que a técnica TF-IDF não seja bem-sucedida em eliminar as stopwords.

Em geral as stop words estão presentes em todos os documentos, fazendo com que o termo $ log(\frac{N}{df_i}) $ tenha o resultado zero, zerando assim a estatística TF-IDF para o termo.

Como existem vários idiomas no dataset esta tendência não se observa fazendo com que não ocorra a eliminação das stop words.

In [32]:
## ---- calculate_idf----|

start  <- Sys.time()

lyrics_token <- bind_tf_idf(tbl = lyrics_token,  
                            term = word, 
                            document = genre, 
                            n = n) %>% 
                arrange(desc(tf_idf)) %>% 
                group_by(genre) %>% 
                mutate(rank_tf_idf  = row_number()) %>% 
                arrange(genre, rank_tf_idf) %>% 
                ungroup()

filter(lyrics_token, rank_tf_idf  <= 3)

end = Sys.time()
mem = pryr::mem_used()

WriteLog('calculate idf', start, end, mem)

## ---- end-of-calculate_idf----|
A tibble: 30 × 9
genrewordntotaltfrank_tfidftf_idfrank_tf_idf
<chr><chr><int><int><dbl><int><dbl><dbl><int>
Country cledus 105 26794873.918661e-0517882.30258519.023049e-051
Country parton 215 26794878.023924e-0511110.69314725.561760e-052
Country ac.guitar 110 26794874.105263e-0517201.20397284.942626e-053
Electronicdibby 388 15448862.511512e-04 4771.20397283.023792e-041
Electronicwub 154 15448869.968373e-05 9312.30258512.295303e-042
Electronicapos 419 15448862.712174e-04 4530.69314721.879936e-043
Folk beremnyi 78 4072091.915478e-04 5922.30258514.410552e-041
Folk cseh 78 4072091.915478e-04 5932.30258514.410552e-042
Folk agus 146 4072093.585382e-04 3401.20397284.316703e-043
Hip-Hop niggas 30288122080262.480991e-03 570.22314365.536171e-041
Hip-Hop nigga 42853122080263.510232e-03 410.10536053.698398e-042
Hip-Hop chamillionaire 690122080265.652019e-0515481.60943799.096574e-053
Indie johnstone 67 6216081.077850e-04 8972.30258512.481841e-041
Indie mooday 41 6216086.595797e-0512632.30258511.518738e-042
Indie leggie 38 6216086.113177e-0513292.30258511.407611e-043
Jazz ik 596 13796484.319942e-04 3150.35667491.540815e-041
Jazz pango 67 13796484.856311e-0516452.30258511.118207e-042
Jazz niet 204 13796481.478638e-04 7220.69314721.024914e-043
Metal iagh 83 40088572.070416e-0534772.30258514.767308e-051
Metal ov 271 40088576.760032e-0514230.69314724.685697e-052
Metal ak'n 80 40088571.995581e-0535442.30258514.594996e-053
Pop 809 99791528.106901e-0510502.30258511.866683e-041
Pop 1126 99791521.128352e-04 8401.60943791.816013e-042
Pop 1429 99791521.431985e-04 7051.20397281.724071e-043
R&B babyface 174 7676592.266631e-04 4880.91629072.076893e-041
R&B sookie 50 7676596.513309e-0511691.20397287.841846e-052
R&B boogum 24 7676593.126388e-0519002.30258517.198775e-053
Rock kimi 1318208565676.319353e-0513050.69314724.380241e-051
Rock boku 644208565673.087756e-0521550.69314722.140270e-052
Rock tiss 276208565671.323324e-0537931.60943792.129808e-053
In [33]:
## ---- top_words_per_genre_tdidf----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 24)

    group_by(lyrics_token, genre) %>%
    top_n(10, tf_idf) %>%
    ungroup() %>% 
    mutate(word = reorder(word, desc(tf_idf))) %>% 
    ggplot(aes(x = fct_reorder(word, tf_idf), 
               y = tf_idf, 
               fill = genre)) +
        geom_col(show.legend = FALSE) +
        facet_wrap( ~ genre, ncol = 2, scales = "free") +
        coord_flip() +
        labs(x = NULL, y = "TF-IDF") +
        theme(text = element_text(size = 20), 
              axis.ticks.x = element_blank(),
              axis.text.x = element_blank())

end  <- Sys.time()

WriteLog('print tf idf', start, end, pryr::mem_used())

## ---- end-of-calculate_idf----|
In [34]:
rm(lyrics_token)
invisible(gc)

LDA Topic Modelling

Agora vamos tentar utilizar a técnica de topic modeling Latent Dirichlet Allocation (LDA) para responder a questão.

Seria possível classificar as canções em grupos que representam os seus respectivos gêneros musicais apenas analisando as letras das músicas?

O dataset que iremos utilizar é o mesmo onde já eliminamos as stop words no início de nosso exercício.

Para contornar limitações computacionais vamos limitar o data set as palavras que aparecem em pelo menos mais de 2 músicas.

In [35]:
## ---- filter_tokens_LDA----|

start  <- Sys.time()

lyrics_token <- readRDS('lyrics_token.rds')
distinct_words <- distinct(lyrics_token, index, word)

song_count <- length(unique(distinct_words$index))

reject_words <- count(distinct_words, word, sort = TRUE) %>% 
                    mutate(prop = n / song_count * 100) %>% 
                    arrange(desc(prop)) %>% 
                    filter(n <= 2)

reject_words <- reject_words$word

print(paste('Número de termos que aparecem em apenas uma música: ', 
            length(reject_words)))

lyrics_token <- filter(lyrics_token, !(word %in% reject_words))

print(paste('Número de tokens: ', 
            nrow(lyrics_token)))

print(paste('Número de termos restante: ', 
            length(unique(lyrics_token$word))))

mem  <- pryr::mem_used()

rm(reject_words, distinct_words, song_count)
invisible(gc)

end = Sys.time()

WriteLog('filter tokens LDA', start, end, mem)

## ---- end-of-filter_tokens_LDA----|
[1] "Número de termos que aparecem em apenas uma música:  275699"
[1] "Número de tokens:  17977140"
[1] "Número de termos restante:  120625"

Mesmo limitando o dataset a palavras que aparecem em mais de duas músicas, necessitaremos limitar o dataset a uma amostra de 50.000 músicas distintas, visto que o tempo de processamento é superior ao permitido para este ambiente.

Para esta versão do notebook, não foi necessário este passo pois executamos o mesmo na nuvem do Google com em uma máquina de 8 núcleos e 54 GB de RAM.

O limite abaixo é adequado para o kernel do Kaggle.

In [6]:
## ---- sampling_tokens_LDA----|

start  <- Sys.time()

print(paste('Número total de músicas: ', length(unique(lyrics_token$index))))

#songs_sample  <- sample(unique(lyrics_token$index), 50000, replace = FALSE)

#print(paste('Número de músicas selecionadas para o LDA: ', length(songs_sample)))

#lyrics_token <- filter(lyrics_token, index %in% songs_sample)

mem  <- pryr::mem_used()
#rm(songs_sample)

end = Sys.time()

WriteLog('sampling tokens LDA', start, end, mem)

## ---- end-of-sampling_tokens_LDA----|
[1] "Número total de músicas:  233413"

Transformamos o nosso dataset em uma matriz de frequência de documentos vs termos (Documento Term Matrix).

In [37]:
## ---- create_dtm----|

start  <- Sys.time()

dtm <- cast_dtm(data = count(lyrics_token, index, word, sort = TRUE),
                weighting = tm::weightTf,
                document = index, 
                term = word, 
                value = n)

dtm

saveRDS(dtm, 'dtm.rds')

mem  <- pryr::mem_used()

end = Sys.time()

WriteLog('calculate dtm', start, end, mem)

## ---- end-of-create_dtm----|
<<DocumentTermMatrix (documents: 233353, terms: 120625)>>
Non-/sparse entries: 11022841/28137182784
Sparsity           : 100%
Maximal term length: 34
Weighting          : term frequency (tf)

Agora treinamos um modelo com 10 tópicos para verificarmos se eles de alguma forma representam os gêneros musicais presentes no dataset.

In [38]:
## ---- LDA_10_topics----|

start  <- Sys.time()

tpm <- LDA(dtm, k = 10, control = list(seed = 123456))

tpm
summary(tpm)

saveRDS(tpm, 'tpm_10.rds')

mem  <- pryr::mem_used()
invisible(gc)

end = Sys.time()

WriteLog('calculate tpm 10', start, end, mem)

## ---- end-of-LDA_10_topics----|
A LDA_VEM topic model with 10 topics.
 Length   Class    Mode 
      1 LDA_VEM      S4 

Agora verificamos quais são os termos com maior ( $ \beta $ ) que representa a probabilidade do termo pertencer ao tópico.

Podemos verificar que alguns tópicos se parecem bastante com as palavras mais comuns de alguns gêneros musicais que observamos na fase de análise exploratória de dados.

Destaque para o gênero Hip-Hop onde claramente conseguimos verificar os mesmos termos no tópico gerado pelo modelo.

Alguns tópicos porém não fazem o menor sentido, claramente aqui temos o efeito de termos algumas músicas em outros idiomas, um tópico quase que classifica as canções em espanhol em um mesmo cluster.

In [7]:
## ---- top_words_per_topic_LDA_10----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 12)

term_topics <- tidy(tpm, matrix = "beta")

term_top_terms <- term_topics %>%
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  arrange(topic, -beta)

term_top_terms %>%
  mutate(term = reorder(term, beta)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free", nrow = 2) +
  coord_flip() +
  theme(text = element_text(size = 20), 
        axis.text.x = element_blank(), 
        axis.ticks = element_blank())

mem  <- pryr::mem_used()

rm(term_topics)
invisible(gc)

end <- Sys.time()

WriteLog('plot top words lda 10', start, end, mem)

## ---- end-of-top_words_per_topic_LDA_10----|

Podemos fazer a junção com o dataset de canções originais e verificar, por gênero musical, para qual tópico cada canção foi assignada pelo modelo LDA.

A probabilidade de cada canção pertencer a um determinado tópico é dada pela estatística ( $ \gamma $ ) do modelo LDA.

In [40]:
## ---- classification_per_genre_LDA_10----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 8)

lyrics <- readRDS('lyrics.rds')
songs_topics <- tidy(tpm, matrix = "gamma")

lyrics$index <- as.character(lyrics$index)

inner_join(lyrics, songs_topics, by = c('index' = 'document')) %>% 
    select(index, song, year, artist, genre, decade, topic, gamma) %>% 
        ggplot(aes(x = factor(topic), y = gamma, fill = genre)) +
            geom_boxplot(show.legend = FALSE, outlier.size = 0.1) +
            facet_wrap(~ genre, nrow = 2) +
            ylim(0, 1) +
            xlab('Topic') + ylab('gamma') +
            labs(title = 'Topic classification per Genre') +
            theme(text = element_text(size = 20), 
                  axis.text.y = element_blank(), 
                  axis.ticks.y = element_blank())

mem  <- pryr::mem_used()

rm(lyrics, songs_topics)
invisible(gc)

end  <- Sys.time()

WriteLog('plot classification per genre lda 10', start, end, mem)

## ---- end-of-classification_per_genre_LDA_10----|

Calculando a média da estatística ( $ \gamma $ ), por gênero, podemos visualizar claramente qual o provável tópico, assignado pelo modelo, para cada gênero musical.

In [41]:
## ---- classification_per_genre_LDA_10_avg_gamma----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 8)

lyrics <- readRDS('lyrics.rds')
songs_topics <- tidy(tpm, matrix = "gamma")

lyrics$index <- as.character(lyrics$index)

inner_join(lyrics, songs_topics, by = c('index' = 'document')) %>% 
    select(index, song, year, artist, genre, decade, topic, gamma) %>% 
    group_by(genre, topic) %>% 
    summarize(mean_gamma = mean(gamma, na.rm = TRUE)) %>% 
    arrange(topic) %>%
        ggplot(aes(x = factor(topic), y = genre, fill = mean_gamma)) +
            geom_bin2d(stat = 'identity', show.legend = FALSE) +
            geom_text(aes(label = round(mean_gamma, 4)), color = 'white', size = 6) +
            scale_fill_gradient(low = "#E53935", high = "#196F3D") +
            theme_minimal() + ylab('Genre') + xlab('Topic') + 
            labs(title = 'Average Gamma by Genre vs Topic') +
            theme(text = element_text(size = 20), 
                  panel.grid = element_blank())

mem  <- pryr::mem_used()

end  <- Sys.time()

WriteLog('plot classification per gere lda 10 avg gamma', start, end, mem)

## ---- end-of-classification_per_genre_LDA_10_avg_gamma----|

Conclusão

Como podemos observar pelo exercício executado acima a técnica TF-IDF não é adequada para este dataset, para a eliminação de stop words, principalmente por que temos algumas canções em outros idiomas que não o idioma principal do dataset (inglês).

Ao utilizar a técnica de topic modeling verificamos que não é possível identificar os 10 gêneros musicais apenas analisando as letras das canções, porém o modelo apresentou alguma eficácia para as músicas do gênero Hip-Hop.

Também verificamos que o algoritmo foi capaz de segregar boa parte das músicas em espanhol e português das músicas em inglês.

Pela análise das probabilidades de classificação dos documentos é possível identificar que talvez 4 ou 5 tópicos poderiam segregar as canções, não necessariamente em gêneros musicais, mas em temas recorrentes, o que faz mais muito sentido, pois na análise exploratória de dados verificamos que os mesmos temas são recorrentes em diferentes gêneros musicais.

Vamos verificar como ficaria a classificação das canções por temas e por gênero musical utilizando um modelo de 5 tópicos apenas.

In [42]:
## ---- LDA_5_topics----|

start  <- Sys.time()

tpm <- LDA(dtm, k = 5, control = list(seed = 123456))

tpm
summary(tpm)

saveRDS(tpm, 'tpm_5.rds')

mem  <- pryr::mem_used()

rm(dtm)
invisible(gc)

end = Sys.time()

WriteLog('calculate tpm 5', start, end, mem)

## ---- end-of-LDA_5_topics----|
A LDA_VEM topic model with 5 topics.
 Length   Class    Mode 
      1 LDA_VEM      S4 
In [43]:
## ---- top_words_per_topic_LDA_5----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 12)

term_topics <- tidy(tpm, matrix = "beta")

term_top_terms <- term_topics %>%
  group_by(topic) %>%
  top_n(20, beta) %>%
  ungroup() %>%
  arrange(topic, -beta)

term_top_terms %>%
  mutate(term = reorder(term, beta)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free", nrow = 1) +
  coord_flip() +
  theme(text = element_text(size = 20), 
        axis.text.x = element_blank(), 
        axis.ticks = element_blank())

mem  <- pryr::mem_used()

rm(term_topics)
invisible(gc)

end <- Sys.time()

WriteLog('plot top words lda 5', start, end, mem)

## ---- end-of-top_words_per_topic_LDA_5----|
In [44]:
## ---- classification_per_genre_LDA_5----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 8)

lyrics <- readRDS('lyrics.rds')
songs_topics <- tidy(tpm, matrix = "gamma")

lyrics$index <- as.character(lyrics$index)

inner_join(lyrics, songs_topics, by = c('index' = 'document')) %>% 
    select(index, song, year, artist, genre, decade, topic, gamma) %>% 
        ggplot(aes(x = factor(topic), y = gamma, fill = genre)) +
            geom_boxplot(show.legend = FALSE, outlier.size = 0.1) +
            facet_wrap(~ genre, nrow = 2) +
            ylim(0, 1) +
            xlab('Topic') + ylab('gamma') +
            labs(title = 'Topic classification per Genre') +
            theme(text = element_text(size = 20), 
                  axis.text.y = element_blank(), 
                  axis.ticks.y = element_blank())

mem  <- pryr::mem_used()
invisible(gc)

end  <- Sys.time()

WriteLog('plot classification per genre lda 5', start, end, mem)

## ---- end-of-classification_per_genre_LDA_5----|
In [45]:
## ---- classification_per_genre_LDA_5_avg_gamma----|

start  <- Sys.time()

options(repr.plot.width = 20, repr.plot.height = 10)

lyrics$index <- as.character(lyrics$index)

inner_join(lyrics, songs_topics, by = c('index' = 'document')) %>% 
    select(index, song, year, artist, genre, decade, topic, gamma) %>% 
    group_by(genre, topic) %>% 
    summarize(mean_gamma = mean(gamma, na.rm = TRUE)) %>% 
    arrange(topic) %>%
        ggplot(aes(x = factor(topic), y = genre, fill = mean_gamma)) +
            geom_bin2d(stat = 'identity', show.legend = FALSE) +
            geom_text(aes(label = round(mean_gamma, 4)), color = 'white', size = 6) +
            scale_fill_gradient(low = "#E53935", high = "#196F3D") +
            theme_minimal() + ylab('Genre') + xlab('Topic') + 
            labs(title = 'Average Gamma by Genre vs Topic') +
            theme(text = element_text(size = 20), 
                  panel.grid = element_blank())

mem  <- pryr::mem_used()
invisible(gc)

end  <- Sys.time()

WriteLog('plot classification per genre lda 5 avg gamma', start, end, mem)

## ---- end-of-classification_per_genre_LDA_5_avg_gamma----|

Para finalizar, vamos observar as canções que tem a maior probabilidade de pertencer ao tópico que aparentemente identificou as observações que estão em outro idioma, que não o inglês.

In [46]:
## ---- classification_non_english----|

start = Sys.time()

group_by(songs_topics, document) %>% 
    arrange(desc(gamma)) %>% 
    filter(row_number() == 1) %>% 
    ungroup() %>% 
    filter(topic == 2) %>% 
    inner_join(lyrics, by = c('document' = 'index')) %>% 
    select(artist, song, genre, decade, gamma, lyrics) %>% 
    mutate(lyrics_preview = str_sub(lyrics, 1, 140)) %>% 
    select(-lyrics) %>% 
    arrange(desc(gamma)) %>% 
    head(25)

end = Sys.time()
mem = pryr::mem_used()

WriteLog('finish', start, end, mem)

## ---- end-of-classification_non_english----|
A tibble: 25 × 6
artistsonggenredecadegammalyrics_preview
<fct><chr><chr><chr><dbl><chr>
extremoduro pedrrk Rock 20000.9992037No me importa que me claves, como a un Cristo, en la pared; ten cuidado, no me falte de comer! T me agarras, yo te empujo, y no me hace falt
chocquibtown de-donde-vengo-yo Hip-Hop20100.9991636De donde vengo yo La cosa no es fácil pero siempre igual sobrevivimos Vengo yo De tanto luchar siempre con la nuestra nos salimos Vengo yo
delillos hjernen-er-alene Rock 20000.9991584deLillos - Hjernen er alene Det er midt på dagen Jeg er alene i huset Jeg står midt i stuen Jeg er alene i huset Jeg stirrer ut av vinduet
don-omar angeles-demonios Hip-Hop20100.9991439Hay veces que ser yo no lo es todo Cuando tienes tanto y sientes no tener nada Caminas por la vida solo Yo callo pero aveces es así que me
fabri-fibra cuore-di-latta Hip-Hop20000.9990851Io sono un ragazzo col cuore di latta Fabri Fibra! io voglio una donna col cuore di latta La ragazza amore mio è ancora chiusa in galera
calle-13 la-perla Hip-Hop20000.9990702Oye, esto va dedicado a todos los barrios de Puerto Rico ¡Trujillo! Dedicado al barrio de la Perla ¡Pocho! Dile a Johana que me haga un ar
aygun-kaza-mova tenha-qada-n-remix Pop 20100.9990078[Aygün Kazımova] Tənha qadın... Tənha qadın bircə addım, [Mone] Tənha bir qadının [Aygün Kazımova] Tənha qadın bircə addım
conecrewdiretoria calma-na-alma Hip-Hop20100.9990027''Nossa senhora das coisas impossiveis que procuramos em vão Vem, soleníssima Soleníssima e cheia de uma vontade oculta de soluçar Talve
don-omar candela Hip-Hop20000.9990003Cualquier semejanza conmigo Es pura casualidad Esto es King of Kings Don Esa nena es candela, Uuuu Candela, uuuu, candela, uuuu Cuerpo perfe
fabri-fibra tutti-matti Hip-Hop20000.9989667Troppo il tempo che sto rinchiuso con le mani mi oriento perchè ho perso l'uso della vista cammino deformando il muso graffiandomi la fac
fabri-fibra tipe-come-te Hip-Hop20000.9989614Prima che sia domani Penso che non ci si annoia per caso, Per casa tutto così ordinato nel caso In cui qualcuno venisse Solitamente parli d
bushido heile-welt Hip-Hop20000.9989365Du lebst in deiner kleinen Welt, es tut uns Leid,du bist leider du, Doch leider kannst du nichts erzählen man von Schweiß und Blut Wir sin
daddy-yankee shaky-shaky-remix Hip-Hop20100.9988983Tamo' en vivo Sube sube sube el mic mic Que vamo' que vamo' Que vamo' pa' la jodedera a full baby Shaky, shaky, shaky, shaky, shaky, shaky,
daddy-yankee shaky-shaky Hip-Hop20100.9988983Tamo' en vivo Sube sube sube el mic mic Que vamo' que vamo' Que vamo' pa' la jodedera a full baby Shaky, shaky, shaky, shaky, shaky, shaky,
fronda underbar Hip-Hop20100.9988921Okej.. Sann historia.. Yeah. Hon var sjutton år, 45 kilo lätt, skinn och ben Men spegeln äter upp det positiva som hon ser Lämna mig ifr
dyablo ten-cuidado Hip-Hop20000.9988573Nunca subestimes Las acciones de este dyablo que est loco Pues porque me aparezco y un infarto te provoco No te me escondas que te encuentro
don-omar good-looking Hip-Hop20100.9988470Nena que bien te vez (Tu modelando) Nena que bien te vez (Cuando caminas) Nena que bien te vez (Sexy bailando) Nena que bien te vez (Subes m
b-b-king boom-boom Rock 20000.9988405ATENCION! Pensaron que nos olvidamos de ustedes Pensaron que no ibamos a volver A que no adivinan quien regreso Este es el nuevo reventon de
fabri-fibra che-cazzata Hip-Hop20000.9988236Yeah Fabri Fibra in the mix in the mix incominciamo incominciamo incominciamo incominciamo incominciamo Qua dentro non si respira qua dentro
emis-killa parole-di-ghiaccio Hip-Hop20100.9988202Rit: Fuori quanto è brutto il tempo però si è calmato il vento il mio sguardo è meno freddo questo inverno sta finendo. Ogni cosa c'ha i
curse dreht-ab Hip-Hop20000.9988059die meisten leute schauen von hier bis zum tellerrand, weiter nicht, die interessiert es was passiert ist bei dallas und weiter nichts, inve
gabriel-o-pensadorcachimbo-da-paz Hip-Hop20000.9987843A criminalidade toma conta da cidade A sociedade põe a cupa nas autoridades O cacique oficial viajou pro Pantanal Porque aqui a violência
gabriel-o-pensadoro-cachimbo-da-paz Hip-Hop20100.9987843A criminalidade toma conta da cidade A sociedade põe a cupa nas autoridades O cacique oficial viajou pro Pantanal Porque aqui a violência
bushido ich-hoffe-es-geht-dir-gutHip-Hop20000.9987806Ich seh' durch deine Augen diesen Hass in dir, Ich seh' wie gern du mich doch abservierst Und du willst sehen wie ich mich krass blamier' Du
bushido es-kommt-wie-es-kommt Hip-Hop20000.9987804Du wurdest mit der Krankheit geboren Bevor du davon erfahren hast kam dir das Leben langweilig vor Ja so langweilig vor Die ganze Lust am Le

Referências